<%@ language="vbscript"%>
<%
Function GetXmpInfo(strFile)
'This function collates the XMP data into an HTML table
	Dim strTemp
	Dim objXMP

	Set objXMP = New XmpBlock
	objXMP.FileName = Server.MapPath(strFile)
	
	If objXMP.GetXmp Then
		GetXmpInfo = GetXmpInfo & "<div class='XmpInfo'>"
		GetXmpInfo = GetXmpInfo & "<table>"
		On Error Resume Next
		'Title
			GetXmpInfo = GetXmpInfo & "<caption>" & objXMP.Item("title") & "</caption>"
		'Description
			GetXmpInfo = GetXmpInfo & "<tr class='trodd'><td class='tdlabel'>Description</td><td colspan='3'>" & objXMP.Item("description") & "</td></tr>"
		'Tags
			GetXmpInfo = GetXmpInfo & "<tr class='treven'><td class='tdlabel'>Keywords</td><td colspan='3'>" & objXMP.Item("subject") & "</td></tr>"
		'Date/Time
			GetXmpInfo = GetXmpInfo & "<tr class='trodd'><td class='tdlabel'>Taken on</td><td colspan='3'>" _
									& WeekdayName(Weekday(objXMP.Item("DateTimeOriginal"))) _
									& ", " & FormatDateTime(objXMP.Item("DateTimeOriginal"), vbLongDate) _
									& " at " & FormatDateTime(objXMP.Item("DateTimeOriginal"), vbLongTime) & "</td></tr>"
		'Location taken
			strTemp = ""
			strTemp = strTemp & objXMP.Item("Location") & ", "
			strTemp = strTemp & objXMP.Item("City") & ", "
			strTemp = strTemp & objXMP.Item("State") & ", "
			strTemp = strTemp & objXMP.Item("Country")
			GetXmpInfo = GetXmpInfo & "<tr class='treven'><td class='tdlabel'>Location</td><td colspan='3'>" _
			& Replace(strTemp, " - , ", "") & "</td></tr>"
		'Creator & Copyright owner
			GetXmpInfo = GetXmpInfo & "<tr class='trodd'><td class='tdlabel'>Creator</td><td>" & objXMP.Item("creator") & "</td>"
		'Copyright
			GetXmpInfo = GetXmpInfo & "<td class='tdlabel'>Copyright</td><td>" & objXMP.Item("rights") & "</td></tr>"
		'Camera make & model
			GetXmpInfo = GetXmpInfo & "<tr class='treven'><td class='tdlabel'>Camera Make</td><td>" & objXMP.Item("Make") & "</td>"
			GetXmpInfo = GetXmpInfo & "<td class='tdlabel'>Model</td><td>" & objXMP.Item("Model") & "</td></tr>"
		'Program mode & aperture
			GetXmpInfo = GetXmpInfo & "<tr class='trodd'><td class='tdlabel'>Exp. Program</td><td>" & objXMP.Item("ExposureProgram") & "</td>"
			GetXmpInfo = GetXmpInfo & "<td class='tdlabel'>Aperture</td><td>" & objXMP.Item("FNumber")
			If (objXMP.Item("ExposureBiasValue") = "0") Or (objXMP.Item("ExposureBiasValue") = "") Then
				GetXmpInfo = GetXmpInfo & "</td></tr>"
			Else
				GetXmpInfo = GetXmpInfo & " (EC " & objXMP.Item("ExposureBiasValue") & ")</td></tr>"
			End If
		'Shutter speed and metering mode
			GetXmpInfo = GetXmpInfo & "<tr class='treven'><td class='tdlabel'>Shutter speed</td><td>" & objXMP.Item("ExposureTime") & "</td>"
			GetXmpInfo = GetXmpInfo & "<td class='tdlabel'>Metering</td><td>" & objXMP.Item("MeteringMode") & "</td></tr>"
		'Focal length & lens used
			GetXmpInfo = GetXmpInfo & "<tr class='trodd'><td class='tdlabel'>Focal Length</td><td>" & objXMP.Item("FocalLength") & "</td>"
			GetXmpInfo = GetXmpInfo & "<td class='tdlabel'>Lens Used</td><td>" & objXMP.Item("Lens") & "</td></tr>"
		'Flash info & ISO rating
			GetXmpInfo = GetXmpInfo & "<tr class='treven'><td class='tdlabel'>Flash</td><td>" & GetFlashInfo & "</td>"
			GetXmpInfo = GetXmpInfo & "<td class='tdlabel'>ISO Rating</td><td>" & objXMP.Item("ISOSpeedRatings") & "</td></tr>"
	
		On Error GoTo 0
		GetXmpInfo = GetXmpInfo & "</table>"
		GetXmpInfo = GetXmpInfo & "</div>"
	Else
		GetXmpInfo "Error - " & Err.Number & ", " & Err.Description & "<br />"
		GetXmpInfo Server.MapPath(strFile)
	End If
	
End Function

Function GetFlashInfo
'This function just makes the flash info tidy without cluttering the GetXmpInfo code
	Dim strFlash
	Dim strReturn
	
	On Error Resume Next
	If objXMP.Item("FlashFired") = "True" Then
		GetFlashInfo = "Fired"
		Select Case objXMP.Item("FlashReturn")
			Case 2
				GetFlashInfo = GetFlashInfo & ", no return"
			Case 3
				GetFlashInfo = GetFlashInfo & ", return detected"
		End Select
	Else
		GetFlashInfo = "Not fired"
	End If
	Select Case objXMP.Item("FlashMode")
		Case 1
			GetFlashInfo = "On, " & GetFlashInfo
		Case 2
			GetFlashInfo = "Off, " & GetFlashInfo
		Case 3
			GetFlashInfo = "Auto, " & GetFlashInfo
	End Select
	If objXMP.Item("FlashRedEyeMode") = "True" Then
		GetFlashInfo = GetFlashInfo & ", Red-eye mode"
	End If
	
	If (objXMP.Item("FlashCompensation") <> "0") And (objXMP.Item("FlashCompensation") <> " - ") Then
		GetFlashInfo = GetFlashInfo & " (FEC " & objXMP.Item("FlashCompensation") & ")"
	End If
End Function

Class XmpBlock
'Extracts the XMP metadata from an Adobe edited JPEG file
'and makes it simpler to access the data, although not all
'values are captured, only the ones that I want so far :).
'
'(C) Copyright Russell Pitcher 2008
'Enquiries: mail russ@theatre64.org
'
'Version 1.0
	
	Private c_strXMP
	Private c_rsXMP
	Private c_objConn
	Private c_blnLoaded
	Private c_blnDecoded
	Private c_strJpegFile
	Private c_objFSO
	Private c_errDesc
	Private c_errFunc
	Private c_xmlXMP
	
	Private Sub Class_Initialize
		Set c_xmlXMP   = CreateObject("Msxml2.DOMDocument.6.0")
		c_xmlXMP.async = False
		Set c_objFSO = CreateObject("Scripting.FileSystemObject")
		Set c_rsXMP  = CreateObject("ADOR.Recordset")
		'adVarChar = 200
		c_rsXMP.Fields.Append "Namespace", 200, 20
		c_rsXMP.Fields.Append "Property",  200, 30
		c_rsXMP.Fields.Append "Value",     200, 255
		c_rsXMP.Open
	End Sub
		
	Public Property Let FileName(JpegFile)
	'Set the file name from which to extract the XMP data
		c_strJpegFile = JpegFile
	End Property
	
	Public Property Get ErrDesc
		ErrDesc = c_errDesc
	End Property
	
	Public Property Get ErrFunc
		ErrDesc = c_errFunc
	End Property
	
	Public Property Get FileName
	'Get the file name for the current XMP block
		FileName = strJpegFile
	End Property
	
	Public Property Get Decoded()
	'Return True if XMP has been successfully loaded
		If c_blnDecoded Then
			Decoded = True
		Else
			Decoded = False
		End If
	End Property
	
	Public Property Get Loaded()
	'Return True if XMP has been successfully loaded
		If c_blnLoaded Then
			Loaded = True
		Else
			Loaded = False
		End If
	End Property
	
	Public Property Get Item(PropertyName)
	'Get the value for a given Property
'		On Error Resume Next
		c_errDesc = ""
		c_errFunc = ""
		c_rsXMP.Filter = " Property = '" & PropertyName & "'"
	
		If c_rsXMP.RecordCount = 0 Then
			Item = " - "
		Else
			c_rsXMP.MoveFirst
			Item = c_rsXMP("Value")
		End If
		c_rsXMP.Filter = ""
	End Property
		
	Public Function GetXmp()
	'Load the XMP block from the JPEG file specified in the [FileName] property
	'Returns True if successful
		On Error Resume Next
		c_errDesc = ""
		c_errFunc = ""
		If c_objFSO.FileExists(c_strJpegFile) Then
			c_xmlXMP.loadXML(GetXmpBlock(c_strJpegFile))
			If Err.Number = 0 Then
				c_blnLoaded = True
				If GetProperties = True Then
					GetXmp = True
					c_blnDecoded = True
				Else
					GetXmp = False
					c_blnDecoded = False
				End If
			Else
				c_errDesc = "Cannot retrieve XMP block from file [" & c_strJpegFile & "]"
				c_errFunc = "GetXmp"
				GetXmp = False
			End If
		Else
			c_errDesc = "Cannot find file [" & c_strJpegFile & "]"
			c_errFunc = "GetXmp"
			GetXmp = False
		End If
	End Function
		
	Public Function Exists(PropertyName)
	'Return True if the specified property has been retrieved from [FileName]
		On Error Resume Next
		c_errDesc = ""
		c_errFunc = ""
		c_rsXMP.Filter = " Property = '" & strService & "'"
	
		If c_rsXMP.RecordCount = 0 Then
			Exists = False
		Else
			Exists = True
		End If
		c_rsXMP.Filter = ""
	End Function
		
	Public Function ListProperties()
	'Return a string list of the properties that this class has retrieved from [FileName]
		c_errDesc = ""
		c_errFunc = ""
		c_rsXMP.Sort = "Namespace, Property"
		If c_rsXMP.RecordCount = 0 Then
			c_errDesc = "No properties found"
			c_errFunc = "ListProperties"
		Else
			c_rsXMP.MoveFirst
			Do Until c_rsXMP.EOF
				WScript.Echo c_rsXMP("Namespace") & ":" & c_rsXMP("Property") & " = " & c_rsXMP("Value")
				c_rsXMP.MoveNext
			Loop
		End If
	End Function
		
	Public Function ToDictionary()
	'Export the XMP data to a Dictionary object
		c_errDesc = ""
		c_errFunc = ""
		Dim dctProperties
		Set dctProperties = CreateObject("Scripting.Dictionary")
		
		On Error Resume Next
		If c_rsXMP.RecordCount > 0 Then
			c_rsXMP.MoveFirst
			Do Until c_rsXMP.EOF
				dctProperties.Add c_rsXMP("NameSpace") & ":" & c_rsXMP("Property"), c_rsXMP("Value")
				c_rsXMP.MoveNext
			Loop
			
			Set ToDictionary = dctProperties
		Else
			ToDictionary = "No Records"
			c_errDesc = "No records to add to dictionary"
			c_errFunc = "ToDictionary()"
		End If
	End Function
		
	Public Function ToHtmlTable()
	'Export XMP data to HTML table string
		c_errDesc = ""
		c_errFunc = ""
		ToHtmlTable = "<p>Not yet implemented</p>"
	End Function
	
	Private Function DecodeValue(strType, strValue)
	'Make sense of coded values
		c_errDesc = ""
		c_errFunc = ""
		Select Case strType
			Case "exif:FNumber"
				If Not IsNull(strValue) Then
					Execute("DecodeValue = ""f/"" & " & strValue)
				Else
					DecodeValue = ""
				End If
			Case "exif:FocalLength"
				If Not IsNull(strValue) Then
					Execute("DecodeValue = " & strValue & " & ""mm""")
				Else
					DecodeValue = ""
				End If
			Case "exif:MeteringMode"
				if not isnull(strValue) Then
					select Case strValue
						case 0
							Value = "Unknown"
						case 1
							DecodeValue = "Average"
						case 2
							DecodeValue = "Centre Weighted Average"
						case 3
							DecodeValue = "Spot"
						case 4
							DecodeValue = "Multi-spot"
						case 5
							DecodeValue = "Evaluative"
						case 6
							DecodeValue = "Partial"
						case 255
							DecodeValue = "Other"
						case else
							DecodeValue = "Undefined (" & strValue & ")"
					End select
				end If
			Case "exif:ColorSpace"
				if not isnull(strValue) Then
					select case strValue
						case 1
							DecodeValue = "sRGB"
						case 2
							DecodeValue = "Adobe RGB"
						case 65535
							DecodeValue = "Uncalibrated"
						case else
							DecodeValue = "Undefined (" & strValue & ")"
					End select
				end If
			Case "exif:DateTimeOriginal"
				If Not IsNull(strValue) Then
					DecodeValue = UTC2Date(Replace(Replace(Replace(Replace(strValue, "-" ,""), ":", ""), "T", ""), ".", ""))
				Else
					DecodeValue = ""
				End If
			Case "exif:ExposureProgram"
				If Not IsNull(strValue) Then
					Select Case strValue
						Case 1
							DecodeValue = "Manual"
						Case 2
							DecodeValue = "Program AE"
						Case 3
							DecodeValue = "Aperture Priority AE"
						Case 4
							DecodeValue = "Shutter Priority AE"
						Case 5
							DecodeValue = "Creative (slow speed)"
						Case 6
							DecodeValue = "Action (high speed)"
						Case 7
							DecodeValue = "Portrait"
						Case 8
							DecodeValue = "Landscape"
						Case Else
							DecodeValue = "Unknown (" & strValue & ")"
					End Select
				End If
 			Case "aux:FlashCompensation"
				If Not IsNull(strValue) Then
					If Left(strValue, 1) = "0" Then
						DecodeValue = "0"
					Else
						If Right(strValue, 2) = "/1" Then
							DecodeValue = Left(strValue, Len(strValue) - 2)
						Else
							DecodeValue = strValue
						End If
						If Left(DecodeValue, 1) <> "-" Then DecodeValue = "+" & DecodeValue
					End If
				End If
			Case "exif:ExposureBiasValue"
				If Not IsNull(strValue) Then
					If Left(strValue, 1) = "0" Then
						DecodeValue = "0"
					Else
						If Right(strValue, 2) = "/1" Then
							DecodeValue = Left(strValue, Len(strValue) - 2)
						Else
							DecodeValue = strValue
						End If
						If Left(DecodeValue, 1) <> "-" Then DecodeValue = "+" & DecodeValue
					End If
				End If
			Case Else
				DecodeValue = strValue
		End Select
	End Function
	
	Private Function GetXmpBlock(strFilePath)
		c_errDesc = ""
		c_errFunc = ""
		On Error Resume Next
		Dim filJpeg
		Dim strBit
		Dim strChunk
		Dim blnStart
		Dim blnEnd
		Dim strXMP
		Set filJpeg = c_objFSO.OpenTextfile(strFilePath)
		
		Do Until filJpeg.AtEndOfStream
			strBit = filJpeg.Read(1)
			If strBit = "<" Then
				strChunk = filJpeg.Read(9)
				Select Case strChunk
					Case "x:xmpmeta"
						blnStart = True
					Case "/x:xmpmet" 
						blnEnd = True
				End Select
			End If
			If blnStart Then
				strXMP = strXMP & strBit & strChunk
			End If
			If blnEnd Then
				strXMP = strXMP & "a>"
				Exit Do
			End If
			strChunk = ""
		Loop
		
		GetXmpBlock = strXMP
	End Function
	
	Private Function GetProperties
	'Get properties from attributes and tags
		Dim colAttr
		Dim objAttr
		c_errDesc = ""
		c_errFunc = ""
		On Error GoTo 0
		'#region <Get rdf:Description attributes>
		Set colAttr = c_xmlXMP.getElementsByTagName("rdf:Description").item(0).attributes
		For Each objAttr In colAttr
			c_rsXMP.AddNew
				c_rsXMP("Namespace") = Left(objAttr.name, InStr(objAttr.name, ":") - 1)
				c_rsXMP("Property")  = Mid(objAttr.name, InStr(objAttr.name, ":") + 1)
				c_rsXMP("Value")     = DecodeValue(objAttr.Name, objAttr.Text)
			c_rsXMP.Update
		Next
		'#endregion
		'#region <Get ISO Rating>
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "exif"
			c_rsXMP("Property")  = "ISOSpeedRatings"
			c_rsXMP("Value")     = c_xmlXMP.getElementsByTagName("exif:ISOSpeedRatings").item(0).text
		c_rsXMP.Update
		'#endregion
		'#region <Get Flash Info>
		On Error Resume Next
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "exif"
			c_rsXMP("Property")  = "FlashFired"
			c_rsXMP("Value")     = c_xmlXMP.getElementsByTagName("exif:Flash").item(0).attributes.getNamedItem("exif:Fired").text
		c_rsXMP.Update
			
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "exif"
			c_rsXMP("Property")  = "FlashReturn"
			c_rsXMP("Value")     = c_xmlXMP.getElementsByTagName("exif:Flash").item(0).attributes.getNamedItem("exif:Return").text
		c_rsXMP.Update
		
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "exif"
			c_rsXMP("Property")  = "FlashMode"
			c_rsXMP("Value")     = c_xmlXMP.getElementsByTagName("exif:Flash").item(0).attributes.getNamedItem("exif:Mode").text
		c_rsXMP.Update
			
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "exif"
			c_rsXMP("Property")  = "FlashRedEyeMode"
			c_rsXMP("Value")     = c_xmlXMP.getElementsByTagName("exif:Flash").item(0).attributes.getNamedItem("exif:RedEyeMode").text
		c_rsXMP.Update
			
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "exif"
			c_rsXMP("Property")  = "FlashFunction"
			c_rsXMP("Value")     = c_xmlXMP.getElementsByTagName("exif:Flash").item(0).attributes.getNamedItem("exif:Function").text
		c_rsXMP.Update
		'#endregion
		'#region <Get Creator info>
		Set colAttr = c_xmlXMP.getElementsByTagName("Iptc4xmpCore:CreatorContactInfo").item(0).attributes
		For Each objAttr In colAttr
			c_rsXMP.AddNew
				c_rsXMP("Namespace") = Left(objAttr.name, InStr(objAttr.name, ":") - 1)
				c_rsXMP("Property")  = Mid(objAttr.name, InStr(objAttr.name, ":") + 1)
				c_rsXMP("Value")     = objAttr.Text
			c_rsXMP.Update
		Next
		
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "dc"
			c_rsXMP("Property")  = "creator"
			c_rsXMP("Value")     = GetDcItem("creator")
		c_rsXMP.Update
		'#endregion
		'#region <Get Description>
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "dc"
			c_rsXMP("Property")  = "description"
			c_rsXMP("Value")     = GetDcItem("description")
		c_rsXMP.Update
		'#endregion
		'#region <Get Copyright>
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "dc"
			c_rsXMP("Property")  = "rights"
			c_rsXMP("Value")     = GetDcItem("rights")
		c_rsXMP.Update
		'#endregion
		'#region <Get Title>
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "dc"
			c_rsXMP("Property")  = "title"
			c_rsXMP("Value")     = GetDcItem("title")
		c_rsXMP.Update
		'#endregion
		'#region <Get Keywords>
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "dc"
			c_rsXMP("Property")  = "subject"
			c_rsXMP("Value")     = GetDcItem("subject")
		c_rsXMP.Update
		'#endregion
		GetProperties = True
	End Function
	
	Private Function GetDcItem(strNodeName)
	'Retrieve data from dc: tags
		c_errDesc = ""
		c_errFunc = ""
		Dim objNode
		Dim objChildNode
		
		GetDcItem = ""
		On Error Resume Next
		Set objNode = c_xmlXMP.getElementsByTagName("dc:" & strNodeName).item(0).childNodes.item(0).childNodes
		If Err.Number = 0 Then
			For Each objChildNode In objNode
				GetDcItem = GetDcItem & objChildNode.text & ", "
			Next
		Else
			GetDcItem = " - "
		End If
		GetDcItem = Left(GetDcItem, Len(GetDcItem) - 2)
		Set objNode = Nothing
		Set objChildNode = Nothing
	End Function

	Private Function UTC2Date(strUTC)
		UTC2Date = Mid(strUTC, 7, 2) & "/" & Mid(strUTC, 5, 2) & "/" & Left(strUTC, 4) _
			& " " & Mid(strUTC, 9, 2) & ":" & Mid(strUTC, 11,2) & ":" & Mid(strUTC, 13, 2)
	End Function

End Class
%>
<!DOCTYPE html PUBLIC '-//W3C//DTD XHTML 1.1//EN' 'http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd'>
<html xmlns='http://www.w3.org/1999/xhtml'>
<head>
	<title>Get-XmpBlock example</title>
	<meta http-equiv='content-type' content='text/xhtml+xml;charset=iso-8859-1' />
	<style type='text/css' media='screen'> <!--
		body,td,p,li,label   {font-size:12px; font-family:Verdana,Arial,Helvetica;}
		h1,h2,h3,h4,h5 {font-family:Tahoma,Arial,Helvetica;}
		label {display: block; float: left; width: 100px; text-align: right; padding-right: 8px; padding-top: 4px;}
		.field {margin-bottom: 4px; padding-bottom: 2px;}
		.centre {text-align: center;}
		.XmpInfo {margin: 6px auto; text-align: center; }
		.XmpInfo table {margin: 6px auto; text-align: center;}
		table {margin: 6px 2px; background-color: #ffffff; font-size: 13px;}
		caption {text-align: center; font-size: 120%; font-weight: bold;}
		td	{padding: 1px 4px; margin: 2px;}
		tr {padding: 2px;}
		.tdlabel {font-weight: bold;}
		.trodd {background-color: #eeeeee; }
		.treven {background-color: #dddddd; }
		-->
	</style>
</head>

<body>
	<h2 class='centre'>Get-XmpBlock Example page</h2>
	<div class='centre'> <img src='BumbleBee.jpg' alt='Bumble bee on flower' /> </div>
	<%=GetXmpInfo("BumbleBee.jpg")%>
	<hr />
	<h4 class='centre'>Replace BumbleBee.jpg with any file that contains an XMP data block.</h4>
</body>
</html>
